home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byte0787.arc / IWPAS.ARC / SHOWEGA2.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-05-12  |  4.9 KB  |  193 lines
  1. PROGRAM ShowEGA(input,output,picfile);
  2.  
  3. { Copyright (c) 1987, Ciarcia's Circuit Cellar          }
  4. {    All Rights Reserved                                }
  5.  
  6. { Version 1.01                  May 12, 1987            }
  7. {   Fixed SendEGA so it would work with more types      }
  8. {    of EGA boards.  kwd                                }
  9.  
  10. { shows image on EGA using histogram "color" assignment }
  11.  
  12. {$U- control-break checking during execution            }
  13. {$C- control-break checking during I/O operations       }
  14. {$R- array range checking                               }
  15.  
  16. {$Ideclares.p                   declarations            }
  17. {$Ihexutil.p                    hex utilities           }
  18. {$Iserial.p                     serial interface code   }
  19. {$Ipictures.p                   picture file code       }
  20. {$Iimages.p                     image processing        }
  21.  
  22. CONST
  23.  EGAint   = $10;                { EGA video services    }
  24.  graymax  = 9;                  { # gray shades - 1     }
  25.  
  26. TYPE
  27.  crng     = 0..graymax;         { gray scale index      }
  28.  cmaptype = ARRAY[bitrng] OF crng;
  29.  
  30. VAR
  31.  r        : regrec;
  32.  cmap     : cmaptype;
  33.  
  34. {--- Assign EGA colors based on histogram               }
  35.  
  36. PROCEDURE ShadeEGA(pic1 : picptr;
  37.                VAR cmap  : cmaptype);
  38.  
  39. VAR
  40.  bin        : bitrng;           { index into bins       }
  41.  binsum     : REAL;             { accumulated # pels    }
  42.  binthresh  : REAL;
  43.  cnum       : crng;             { color numbers         }
  44.  histo      : histtype;         { intensity histogram   }
  45.  
  46. BEGIN
  47.  
  48.  Writeln('Computing histogram');
  49.  Histogram(pic1,histo);         { compute histogram     }
  50. (****
  51.  ShowHist(histo);
  52.  Readln;
  53. ****)
  54. {--- first and last colors are each given half a bin    }
  55.  
  56.  Writeln('Assigning colors');
  57.  
  58.  binthresh := (maxpel+1.0)*(maxline+1.0)/(graymax+1.0);
  59.  cnum := 0;                     { start with black...   }
  60.  binsum :=  -(binthresh/2.0);   {   with 1.5 bins       }
  61.  FOR bin := 0 TO maxbit DO BEGIN
  62.   cmap[bin] := cnum;            { assign current color  }
  63.   binsum := binsum + histo[bin];  { accumulate counts   }
  64.   IF binsum >= binthresh        { into next color yet?  }
  65.    THEN BEGIN                   { yes, reset accumulator}
  66.     IF cnum < graymax           { and tick color number }
  67.      THEN cnum := cnum + 1;
  68.     binsum := binsum - binthresh;
  69.    END;
  70.  END;
  71.  
  72. END;
  73.  
  74.  
  75. {--- Show picture on EGA                                }
  76. {    two EGA pels are used for each image pel to        }
  77. {    help aspect ratio and allow gray scale dithering   }
  78.  
  79. PROCEDURE SendEGA(pic  : picptr;
  80.                   cmap : cmaptype);
  81.  
  82. VAR
  83.  r         : regrec;            { BIOS interface regs   }
  84.  row,col   : INTEGER;           { EGA coordinates       }
  85.  lndx      : linerng;           { line number           }
  86.  pndx      : pelrng;            { pel number            }
  87.  pelval1   : INTEGER;           { pel value left        }
  88.  pelval2   : INTEGER;           { pel value right       }
  89.  
  90. BEGIN
  91.  
  92.  r.AX := ($00 SHL 8) OR $10;    { 640 x 350 / 16 colors }
  93.  Intr(EGAint,r);
  94.  
  95.  row := 50;
  96.  FOR lndx := 0 TO maxline DO BEGIN
  97.   col := 64;
  98.   FOR pndx := 0 TO maxpel DO BEGIN
  99.    CASE cmap[pic^.fmt.lines[lndx].pels[pndx]] OF
  100.      0 : BEGIN
  101.           pelval1 := 0;
  102.           pelval2 := 0;
  103.          END;
  104.      1 : BEGIN
  105.           pelval1 := 0;
  106.           pelval2 := 8;
  107.          END;
  108.      2 : BEGIN
  109.           pelval1 := 8;
  110.           pelval2 := 8;
  111.          END;
  112.      3 : BEGIN
  113.           pelval1 := 8;
  114.           pelval2 := 7;
  115.          END;
  116.      4 : BEGIN
  117.           pelval1 := 0;
  118.           pelval2 := 7;
  119.          END;
  120.      5 : BEGIN
  121.           pelval1 := 7;
  122.           pelval2 := 7;
  123.          END;
  124.      6 : BEGIN
  125.           pelval1 := 0;
  126.           pelval2 := 15;
  127.          END;
  128.      7 : BEGIN
  129.           pelval1 := 8;
  130.           pelval2 := 15;
  131.          END;
  132.      8 : BEGIN
  133.           pelval1 := 7;
  134.           pelval2 := 15;
  135.          END;
  136.      9:  BEGIN
  137.           pelval1 := 15;
  138.           pelval2 := 15;
  139.          END;
  140.      ELSE
  141.          BEGIN
  142.           pelval1 := 14;
  143.           pelval2 := 14;
  144.          END;
  145.    END;
  146.    r.AH := $0C;
  147.    r.AL := pelval1;
  148.    r.BX := $0000;
  149.    r.CX := col;
  150.    r.DX := row;
  151.    Intr(EGAint,r);
  152.    col := Succ(col);
  153.    r.AH := $0C;
  154.    r.AL := pelval2;
  155.    r.BX := $0000;
  156.    r.CX := col;
  157.    r.DX := row;
  158.    Intr(EGAint,r);
  159.    col := Succ(col);
  160.   END;
  161.   row := Succ(row);
  162.   IF KeyPressed
  163.    THEN BEGIN
  164.     TextMode;
  165.     HALT;
  166.    END;
  167.  END;
  168.  
  169. END;
  170.  
  171. {--- Main routine                                       }
  172.  
  173. BEGIN
  174.  
  175.  
  176.  pic1 := NIL;                   { ensure new alloc      }
  177.  PicSetup(pic1);                { set up picture array  }
  178.  
  179.  filespec := GetFSpec(ParamStr(1));
  180.  
  181.  LoadPicture(filespec,pic1);    { read picture          }
  182.  
  183.  ShadeEGA(pic1,cmap);           { determine color map   }
  184.  
  185.  SendEGA(pic1,cmap);            { send mapped picture   }
  186.  
  187.  GoToXY(1,24);
  188.  Write('Press Enter');
  189.  Readln;
  190.  TextMode;
  191.  
  192. END.
  193.